(defpackage :diagram
  (:use :cl :boxes.util)
  (:nicknames :d)
  (:export :*debug*
           :*verbose-node-printing*
           :diagram
           :vpadding
           :hpadding
           :arg-padding
           :box-margin
           :arg-margin
           :min-box-width
           :min-box-height
           :min-arg-width
           :arrow-thickness
           :arrow-color
           :node-arrow-color
           :selected-color
           :root
           :diagram-view
           :gravity
           :guide
           :update-diagram-view
           :event-callback
           :get-unique-id
           :id
           :reset-id-counter
           :property
           :base-node
           :box
           :multi-argument-box
           :invisible-node
           :invisible-box
           :argument-content-size
           :space-node
           :arrange-child-boxes
           :space-tree
           :draw-node
           :draw-node-arrow
           :best-arrow-direction
           :interactive-mixin
           :selected
           :selected-nodes
           :arrow
           :highlighted
           :highlight-color
           :debug-text
           :box-left-arg
           :box-operator-arg
           :box-right-arg
           :box-left
           :box-operator
           :box-right
           :parent-box
           :parent-boxes
           :other-child-boxes
           :child-boxes
           :normal-box-p
           :foreground
           :background
           :outline
           :font
           :font-color
           :argument
           :quantity
           :input-argument
           :input-argument-num-fields
           :answer
           :hint
           :mistake
           :input-location
           :single-input-argument
           :number-input-argument
           :operator-input-argument
           :multi-input-argument
           :number-operator-input-argument
           :operator-number-input-argument
           :number-operator-number-input-argument
           :invisible-argument
           :valid-input-p
           :funcall-on-tree
           :find-if-on-tree
           :find-on-tree
           :collect-on-tree
           :tree-dimensions
           :tree-coordinates
           :tree-rectangle
           :tree-right-edge
           :tree-left-edge
           :move-tree
           :move-tree-left
           :move-tree-right
           :move-tree-up
           :move-multiparent-subtree
           :leaf-box-p
           :normal-leaf-box-p
           :xbox-p
           :multiparent-box-p
           :single-parent-box-p
           :single-parent-p
           :spacing-failed-p
           :allow-dragging-p
           :make-x-box
           :clear-arrows
           :clear-selected
           :clear-highlights
           :find-node-by-id
           :find-id-or-die
           :merge-by-id
           :descendants-of
           :center-root
           :box-x
           :box-y
           :box-right
           :box-bottom
           :box-centerx
           :box-centery
           :tree-x
           :tree-y
           :only-boxes
           :point-to-nodes))

(in-package :diagram)

(defvar *debug* nil
  "enable debug output.")

(defvar *verbose-node-printing* nil
  "To include a bunch of extra slots when printing a node, set this to non-NIL")

;;; Diagram class and API

(defclass diagram (gwee:foreground-mixin)
  ((root :accessor root)
   (box-margin :initarg :box-margin :accessor box-margin)
   (arg-margin :initarg :arg-margin :accessor arg-margin)
   (arg-padding :initarg :arg-padding :accessor arg-padding)
   (hpadding :initarg :hpadding :accessor hpadding)
   (vpadding :initarg :vpadding :accessor vpadding)
   (min-box-width :initarg :min-box-width :accessor min-box-width)
   (min-arg-width :initarg :min-arg-width :accessor min-arg-width)
   (min-box-height :initarg :min-box-height :accessor min-box-height)
   (arrow-thickness :initarg :arrow-thickness :accessor arrow-thickness)
   (arrow-color :initarg :arrow-color :accessor arrow-color)
   (node-arrow-color :initarg :node-arrow-color :accessor node-arrow-color)
   (selected-color :initarg :selected-color :accessor selected-color)
   (highlight-color :initarg :highlight-color :accessor highlight-color)
   (spacing-failed-p :initform nil :accessor spacing-failed-p)
   (allow-dragging-p :initform nil :initarg :allow-dragging :accessor allow-dragging-p))
  (:default-initargs
    :hpadding 10
    :vpadding 20
    :box-margin 5
    :arg-margin 2
    :arg-padding 5
    :min-box-width 119
    :min-box-height 51
    :min-arg-width 33
    :arrow-thickness 5
    :arrow-color (gwee:gray 150)
    :node-arrow-color (sdl:color :r 0 :g 255 :b 0 :a 200)
    :selected-color (gwee:color 255 50 20)
    :highlight-color (gwee:gray 0)
    :font (gwee:open-font "sans.ttf" 36)))

(defgeneric argument-content-size (node diagram)
  (:documentation "return values width and height for the argument's content."))
(defgeneric space-node (node diagram))
(defgeneric arrange-child-boxes (node diagram))
(defgeneric draw-node (node diagram))
(defgeneric draw-node-arrow (node diagram))
(defgeneric best-arrow-direction (node diagram))
(defgeneric space-tree (diagram))

(defclass diagram-view (gwee:view gwee:background-mixin diagram)
  ((event-callback :initarg :event-callback :accessor event-callback)
   (gravity :type (member :top :center :bottom :left :right :north :south :east :west :north-east :north-west :south-west :south-east) :initform :center :initarg :gravity :accessor gravity)
   (guide :initform 0 :initarg :guide :accessor guide))
  (:documentation "The base class for implementing different drawing schemes for the tree."))

(defgeneric update-diagram-view (view))

(defmethod update-diagram-view :after ((view diagram-view))
  (setf (gwee:view-needs-update-p view) t))

;;; Tree node classes

(defvar *id-counter* 0)
(defun get-unique-id ()
  (incf *id-counter*))
(defun reset-id-counter ()
  (setf *id-counter* 0))

(defclass id-mixin ()
  ((id :initform (get-unique-id) :initarg :id :accessor id)))

(defmethod u:copy-slots progn ((node id-mixin) (obj id-mixin))
  (u:simple-copy-slots node obj 'id))

(defclass interactive-mixin ()
  ((selected :initarg :selected :initform nil :accessor selected)
   (highlighted :initarg :highlighted :initform nil :accessor highlighted)
   (arrow :initarg :arrow :initform nil :accessor arrow)
   (debug-text :initform nil :accessor debug-text)))

(defmethod tree:node-equal and ((node1 interactive-mixin) (node2 interactive-mixin))
  (eq (selected node1) (selected node2)))

(defmethod u:copy-slots progn ((node interactive-mixin) (obj interactive-mixin))
  (u:simple-copy-slots node obj 'selected 'arrow 'highlighted 'debug-text))

(defclass base-node (geom:rectangle tree:node id-mixin)
  ((plist :initform (make-hash-table) :accessor base-node-plist)))

(defmethod u:copy-slots progn ((node base-node) (obj base-node))
  (maphash (lambda (k v)
             (setf (gethash k (base-node-plist obj)) v))
           (base-node-plist node)))

(defmethod (setf property) (val (node base-node) key)
  (setf (gethash key (base-node-plist node)) val))

(defmethod property ((node base-node) key)
  (gethash key (base-node-plist node)))

(defclass box (base-node interactive-mixin)
  ())

(defclass multi-argument-box (box)
  ())

(defclass invisible-node ()
  ())

(defclass invisible-box (multi-argument-box invisible-node)
  ()
  (:documentation "A box to give the appearance of multiple root nodes in the diagram."))

(defmethod print-object ((obj multi-argument-box) stream)
  (format stream "[~s ~{~a~^ ~}~{ ~s~}]" (type-of obj) (tree:children obj) `(,@(when (selected obj) `(:selected t)) :id ,(id obj)
                                                                             ,@(when *verbose-node-printing*
                                                                                     `(:x ,(geom:x obj)
                                                                                       :y ,(geom:y obj)
                                                                                       :width ,(geom:width obj)
                                                                                       :height ,(geom:height obj)
                                                                                       :arrow ,(arrow obj)
                                                                                       :highlighted ,(highlighted obj))))))

(defgeneric box-left-arg (box))
(defgeneric box-operator-arg (box))
(defgeneric box-right-arg (box))

(defgeneric box-left (box))
(defgeneric box-operator (box))
(defgeneric box-right (box))

(defmethod box-left-arg ((box multi-argument-box))
  (first (tree:children box)))

(defmethod box-operator-arg ((box multi-argument-box))
  (second (tree:children box)))

(defmethod box-right-arg ((box multi-argument-box))
  (third (tree:children box)))

(defmethod box-left ((box multi-argument-box))
  (tree:child (box-left-arg box)))

(defmethod box-operator ((box multi-argument-box))
  (tree:child (box-operator-arg box)))

(defmethod box-right ((box multi-argument-box))
  (tree:child (box-right-arg box)))

(defun child-boxes (box)
  "Return a list of boxes that are children of the arguments of box."
  (apply 'append (mapcar 'tree:children (tree:children box))))

(defun other-child-boxes (box &rest excluded-children)
  "Return the child boxes not in the EXCLUDED-CHILDREN list."
  (set-difference (child-boxes box) excluded-children))

(defun parent-boxes (box)
  (check-type box box)
  (mapcar 'tree:parent (tree:parents box)))

(defun parent-box (box)
  (let ((p (parent-boxes box)))
    (assert (<= (length p) 1))
    (first (parent-boxes box))))

(defun descendants-of (box all-boxes)
  (u:collect-if (lambda (b) (tree:descendant-p box b)) all-boxes))

(defclass color-parts-mixin ()
  ((foreground :initarg :foreground :accessor foreground)
   (background :initarg :background :accessor background)
   (outline :initarg :outline :accessor outline)
   (font :initarg :font :accessor font)
   (font-color :initarg :font-color :accessor font-color)
   (arrow-color :initarg :arrow-color :initform nil :accessor arrow-color)))

(defmethod u:copy-slots progn ((node color-parts-mixin) (obj color-parts-mixin))
  (u:simple-copy-slots node obj 'foreground 'background 'outline 'font 'font-color 'arrow-color))

(defclass argument (base-node interactive-mixin color-parts-mixin)
  ((quantity :initarg :quantity :accessor quantity))
  (:default-initargs
   :foreground (gwee:gray 0)
    :outline (gwee:gray 200)
    :background (gwee:gray 240)))

(defmethod argument-content-size ((arg argument) diagram)
  (values (text-width (d:quantity arg) (gwee:view-font diagram))
          (sdl:get-font-height :font (gwee:view-font diagram))))

(defclass invisible-argument (argument invisible-node)
  ()
  (:documentation "exists inside invisible-boxes."))

(defmethod tree:node-equal and ((node1 argument) (node2 argument))
  (eql (quantity node1) (quantity node2)))

(defmethod u:copy-slots progn ((node argument) (obj argument))
  (u:simple-copy-slots node obj 'quantity))

(defclass input-argument (argument tree:single-child-mixin)
  ((answer :initarg :answer :accessor answer)
   (mistake :initform nil :initarg :mistake :accessor mistake)
   (hint :initarg :hint :accessor hint)
   (input-location :initform :below :initarg :input-location :accessor input-location))
  (:default-initargs
   :foreground (gwee:gray 0)
    :background (gwee:color 173 216 230)))

(defmethod u:copy-slots progn ((node input-argument) (obj input-argument))
  (u:simple-copy-slots node obj 'answer 'mistake 'hint 'input-location))

(defclass single-input-argument (input-argument)
  ()
  (:documentation "The quantity field contains a single value."))

(defclass number-input-argument (single-input-argument)
  ())

(defclass operator-input-argument (single-input-argument)
  ())

(defclass multi-input-argument (input-argument)
  ((num-fields :initarg :num-fields :accessor input-argument-num-fields))
  (:documentation "the quantity field is a list of quantities instead of a single one."))

(defclass number-operator-input-argument (multi-input-argument)
  ()
  (:default-initargs
   :num-fields 2))

(defclass operator-number-input-argument (multi-input-argument)
  ()
  (:default-initargs
   :num-fields 2))

(defclass number-operator-number-input-argument (multi-input-argument)
  ()
  (:default-initargs
   :num-fields 3))

(defun export-color (color)
  `(gwee:color ,(sdl:r color) ,(sdl:g color) ,(sdl:b color)))

(defmethod print-object ((obj argument) stream)
  (format stream "[~s ~a~a ~{~a ~}~{ ~s~}]" (type-of obj) (if (symbolp (quantity obj)) "'" "") (quantity obj) (tree:children obj) `(,@(when (selected obj) `(:selected t))
                                                                                                                                      :background ,(u:sharp-dot (export-color (background obj))) :id ,(id obj)
                                                                                                                                      ,@(when *verbose-node-printing*
                                                                                                                                              `(:x ,(geom:x obj)
                                                                                                                                                :y ,(geom:y obj)
                                                                                                                                                :width ,(geom:width obj)
                                                                                                                                                :height ,(geom:height obj)
                                                                                                                                                :arrow ,(arrow obj)
                                                                                                                                                :highlighted ,(highlighted obj))))))

(defmethod print-object ((obj input-argument) stream)
  (format stream "[~s ~a~a ~{~a ~}~{ ~s~}]" (type-of obj) (if (symbolp (quantity obj)) "'" "")  (quantity obj) (tree:children obj) `(,@(when (selected obj) `(:selected t)) :answer ,(answer obj) :id ,(id obj)
                                                                                                                                     ,@(when *verbose-node-printing*
                                                                                                                                             `(:x ,(geom:x obj)
                                                                                                                                               :y ,(geom:y obj)
                                                                                                                                               :width ,(geom:width obj)
                                                                                                                                               :height ,(geom:height obj)
                                                                                                                                               :input-location ,(input-location obj)
                                                                                                                                               :arrow ,(arrow obj)
                                                                                                                                               :highlighted ,(highlighted obj))))))

(defgeneric valid-input-p (arg string))

(defmethod valid-input-p ((arg number-input-argument) string)
  (and (parse:num string) t))

(defmethod valid-input-p ((arg operator-input-argument) string)
  (and (parse:op string) t))

(defmethod valid-input-p ((arg number-operator-number-input-argument) string)
  (and (parse:num-op-num string) t))

(defmethod valid-input-p ((arg number-operator-input-argument) string)
  (and (parse:num-op string) t))

(defmethod valid-input-p ((arg operator-number-input-argument) string)
  (and (parse:op-num string) t))

;;; functions for probing the tree

;; a kludge to keep track of multiparent nodes so we don't process them twice
(defstruct multi-parent-collector
  nodes)

(defgeneric funcall-on-tree-method (node fn when only-type mp))

(defmethod funcall-on-tree-method ((node tree:base-node) fn when only-type mp)
  (dolist (i (tree:children node))
    (unless (find i (multi-parent-collector-nodes mp))
      (funcall-on-tree-method i fn when only-type mp))
    (when (> (length (tree:parents i)) 1)
      (pushnew i (multi-parent-collector-nodes mp)))))

(defmethod funcall-on-tree-method :after ((node tree:base-node) fn (when (eql :after)) only-type mp)
  (when (or (not only-type)
            (typep node only-type))
  (funcall fn node)))

(defmethod funcall-on-tree-method :before ((node tree:base-node) fn (when (eql :before)) only-type mp)
  (when (or (not only-type)
            (typep node only-type))
  (funcall fn node)))

(defun funcall-on-tree (fn node &key (when :before) only-boxes only-type)
  (funcall-on-tree-method node fn when (or (when only-boxes 'box)
                                           only-type)
                          (make-multi-parent-collector)))

(defun find-if-on-tree (fn node &key (key 'identity) from-end only-boxes only-type)
  (funcall-on-tree (lambda (n)
		     (when (funcall fn (funcall key n))
		       (return-from find-if-on-tree n)))
		   node
		   :when (if from-end :after :before)
                   :only-boxes only-boxes
                   :only-type only-type)
  nil)

(defun find-on-tree (item node &key (key 'identity) (test 'eq) from-end)
  (find-if-on-tree (lambda (n)
		     (funcall test (funcall key n) item))
		   node
		   :from-end from-end))

(defun collect-on-tree (fn node &key (key 'identity) from-end only-boxes only-type)
  (let (acc)
    (funcall-on-tree (lambda (n)
                       (when (funcall fn (funcall key n))
                         (setf acc (append acc (list n)))))
                     node
                     :when (if from-end :after :before)
                     :only-boxes only-boxes
                     :only-type only-type)
    acc))

;;; Helper functions for moving the tree around and probing its size

(defun move-tree (root x y &optional absolutep ignore-multi-parents-p)
  (tree:with-iterator (iterate b recurse)
    (unless (and (u:neq b root)
                 ignore-multi-parents-p
                 (typep b 'box)
                 (> (length (tree:parents b)) 1))
        (incf (geom:x b) x)
        (incf (geom:y b) y)
        (recurse))
    ;; body
    (when absolutep
      (setf x (- x (geom:x root))
            y (- y (geom:y root))))
    (iterate root)))

(defun move-multiparent-subtree (root x y &optional absolutep)
  "Call this to move a subtree starting with a multiparent box. All boxes whose parents are all descendants of root are moved."
  (tree:with-iterator (iterate b recurse)
      (when (or (eq b root)
                (not (typep b 'box))
                (every (lambda (p) (tree:descendant-p p root))
                       (tree:parents b)))
        (incf (geom:x b) x)
        (incf (geom:y b) y)
        (recurse))
    ;; body
    (when absolutep
      (setf x (- x (geom:x root))
            y (- y (geom:y root))))
    (iterate root)))

(defun move-tree-up (root diagram &optional (amt (+ (geom:height root) (vpadding diagram))))
  (move-tree root 0 (- amt)))

(defun move-tree-right (root diagram &optional (amt (+ (geom:width root) (hpadding diagram))))
  (move-tree root amt 0))

(defun move-tree-left (root diagram &optional (amt (+ (geom:width root) (hpadding diagram))))
  (move-tree root (- amt) 0))

(defun tree-dimensions (root &optional skip-multi-parents skip-x-boxes)
  (let (acc)
    (tree:with-iterator (iterate b recurse 'box)
        (unless (or (and skip-multi-parents
                         (u:neq b root)
                         (multiparent-box-p b))
                    (and skip-x-boxes
                         (xbox-p b)))
            (push b acc)
            (recurse))
      ;; body
      (iterate root)
      ;;(print `(dim ,skip-multi-parents ,skip-x-boxes ,(mapcar 'childq acc)))
      (loop for b in acc
           minimize (geom:x b) into minx
           minimize (geom:y b) into miny
           maximize (geom:right b) into maxx
           maximize (geom:bottom b) into maxy
           finally (return (geom:pt (- maxx minx) (- maxy miny)))))))

(defun tree-coordinates (root &optional skip-multi-parents skip-x-boxes)
  (let ((x (geom:x root))
	(y (geom:y root)))
    (tree:with-iterator (iterate b recurse)
        (unless (or (and skip-multi-parents
                         ;;(not (u:neq b root))
                         (multiparent-box-p b))
                    (and skip-x-boxes
                         (xbox-p b)))
          (when (typep b 'box)
            (when (< (geom:x b) x)
              (setf x (geom:x b)))
            (when (< (geom:y b) y)
              (setf y (geom:y b))))
          (recurse))
      ;; body
      (iterate root)
      (geom:point x y))))

(defun tree-rectangle (root &optional skip-multi-parents skip-x-boxes)
  (let ((x (geom:x root))
	(y (geom:y root))
	(width (geom:right root))
	(height (geom:bottom root)))
    (tree:with-iterator (iterator b recurse)
        (unless (or (and skip-multi-parents
                         ;;(not (u:neq b root))
                         (multiparent-box-p b))
                    (and skip-x-boxes
                         (xbox-p b)))
          (when (typep b 'box)
            (when (< (geom:x b) x)
              (setf x (geom:x b)))
            (when (< (geom:y b) y)
              (setf y (geom:y b)))
            (when (> (geom:right b) width)
              (setf width (geom:right b)))
            (when (> (geom:bottom b) height)
              (setf height (geom:bottom b))))
          (recurse))
      ;; body
      (iterator root)
      (make-instance 'geom:rectangle
                     :x x :y y
                     :width (- width x)
                     :height (- height y)))))

(defun tree-right-edge (root)
  (geom:right (tree-rectangle root)))

(defun tree-left-edge (root)
  (geom:x (tree-coordinates root)))

;;; Helper functions for boxes

(defun leaf-box-p (box)
  "Return T when the arguments of box have no children."
  (and (typep box 'multi-argument-box)
       (every (lambda (arg)
                (null (tree:children arg)))
              (tree:children box))))

(defun multiparent-box-p (box)
  (and (typep box 'box)
       (> (length (tree:parents box)) 1)))

(defun single-parent-p (box)
  (and (typep box 'box)
       (= (length (tree:parents box)) 1)))

(defun normal-leaf-box-p (box)
  "A leaf box with only one parent."
  (and (leaf-box-p box)
       (single-parent-p box)))

(defun normal-box-p (box)
  (and (single-parent-p box)
       (= (length (tree:children box)) 3)))

(defun xbox-p (box)
  (and (leaf-box-p box)
       (tree:parents box)
       ;; don't mistake an x-box for a bottom box
       (notany (lambda (arg) (typep arg 'invisible-argument))
               (tree:parents box))
       (<= (length (tree:children box)) 1)))

;;; reader macro to make it easier to input these trees

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun bracket-reader (stream char)
    (declare (ignore char))
    (labels ((match (thing &rest symbols)
               (find thing symbols :key 'symbol-name :test 'string=))
             (match-number (thing)
               (numberp thing))
             (extract (elts)
               (let* ((p (position-if 'keywordp elts))
                      (children (subseq elts 0 p))
                      (keywords (when p (subseq elts p))))
                 (values children keywords))))
    (let ((box (read-delimited-list #\] stream)))
      (cond
	((or (match-number (first box))
             (match (first box) '+ '- '* '/))
	 (destructuring-bind (&rest keywords &key &allow-other-keys) (rest box)
	 `(make-instance 'argument :children nil :quantity ',(first box) ,@keywords)))
        ((match (first box) 'multi-argument-box 'multi 'm)
	 (let* ((p (position-if 'keywordp box))
		(children (subseq (rest box) 0 (when p (1- p))))
		(keywords (when p (subseq (rest box) (1- p)))))
	   `(make-instance 'multi-argument-box :children (list ,@children) ,@keywords)))
        ((match (first box) 'invisible-box)
	 (let* ((p (position-if 'keywordp box))
		(children (subseq (rest box) 0 (when p (1- p))))
		(keywords (when p (subseq (rest box) (1- p)))))
	   `(make-instance 'invisible-box :children (list ,@children) ,@keywords)))
	((match (first box) 'argument 'a)
         (multiple-value-bind (children keywords) (extract (cddr box))
	   `(make-instance 'argument :children (list ,@children) :quantity ,(second box) ,@keywords)))
	((match (first box) 'invisible-argument)
         (multiple-value-bind (children keywords) (extract (cddr box))
	   `(make-instance 'invisible-argument :children (list ,@children) :quantity ,(second box) ,@keywords)))
	((match (first box) 'number-input-argument 'i 'ni)
         (multiple-value-bind (children keywords) (extract (cddr box))
	   `(make-instance 'number-input-argument :children (list ,@children) :quantity ,(second box) ,@keywords)))
	((match (first box) 'operator-input-argument 'oi)
	 (destructuring-bind (quantity &rest keywords &key &allow-other-keys) (rest box)
	   `(make-instance 'operator-input-argument :child nil :quantity ,quantity ,@keywords)))
        ((match (first box) 'number-operator-input-argument 'noi)
         (destructuring-bind (quantity &rest keywords &key &allow-other-keys) (rest box)
	   `(make-instance 'number-operator-input-argument :quantity ',quantity ,@keywords)))
        ((match (first box) 'operator-number-input-argument 'oni)
         (destructuring-bind (quantity &rest keywords &key &allow-other-keys) (rest box)
	   `(make-instance 'operator-number-input-argument :quantity ',quantity ,@keywords)))
        ((match (first box) 'number-operator-number-input-argument 'noni)
         (destructuring-bind (quantity &rest keywords &key &allow-other-keys) (rest box)
	   `(make-instance 'number-operator-number-input-argument :quantity ',quantity ,@keywords)))
        (t (error "unknown node type ~s" (first box))))))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (set-macro-character #\[ 'bracket-reader)
  (set-macro-character #\] (get-macro-character #\))))

(defun make-x-box ()
  (make-instance 'multi-argument-box))

(defun selected-nodes (tree)
  (d:collect-on-tree 'd:selected tree))

(defun clear-arrows (tree)
  (d:funcall-on-tree (lambda (n) (setf (d:arrow n) nil)) tree))

(defun clear-selected (tree)
  (d:funcall-on-tree (lambda (n) (setf (d:selected n) nil)) tree))

(defun clear-highlights (tree)
  (d:funcall-on-tree (lambda (n) (setf (highlighted n) nil)) tree))

(defun find-node-by-id (tree id)
  (find-on-tree id tree :key 'id :test 'eql))

(defun find-id-or-die (tree id)
  (or (find-node-by-id tree id)
      (error "ID ~a was not found." id)))

(defun merge-by-id (tree)
  "All boxes with the same ID should have their parents merged."
  (let ((boxes (d:collect-on-tree (constantly t) tree :only-boxes t)))
    (loop for b on boxes
       for i = (car b)
         do (loop for j in (cdr b)
          when (eq (d:id i) (d:id j))
          do (setf (tree:parents i) (append (tree:parents i) (tree:parents j))
                   (tree:parents j) nil)))
    tree))

(defun center-root (v)
  (let ((r (tree-rectangle (root v))))
    (setf (tree-x (root v)) (+ (- (geom:x (root v)) (geom:x r))
                               (truncate (- (gwee:view-width v) (geom:width r)) 2))
          (tree-y (root v)) (+ (- (geom:y (root v)) (geom:y r))
                               (truncate (- (gwee:view-height v) (geom:height r)) 2)))))

(defgeneric (setf box-x) (x box))
(defgeneric (setf box-y) (y box))
(defgeneric (setf box-right) (x box))
(defgeneric (setf box-bottom) (y box))
(defgeneric (setf box-centerx) (x box))
(defgeneric (setf box-centery) (y box))
(defgeneric (setf tree-x) (x box))
(defgeneric (setf tree-y) (y box))

(defmethod (setf box-x) (x (box box))
  (let ((delta (- x (geom:x box))))
    (setf (geom:x box) x)
    (mapc (lambda (n) (incf (geom:x n) delta)) (tree:children box))))
  
(defmethod (setf box-y) (y (box box))
  (let ((delta (- y (geom:y box))))
    (setf (geom:y box) y)
    (mapc (lambda (n) (incf (geom:y n) delta)) (tree:children box))))

(defmethod (setf box-right) (x (box box))
  (setf (box-x box) (- x (geom:width box))))
  
(defmethod (setf box-bottom) (y (box box))
  (setf (box-y box) (- y (geom:height box))))

(defmethod (setf box-centerx) (x (box box))
  (setf (box-x box) (- x (u:half (geom:width box)))))

(defmethod (setf box-centery) (y (box box))
  (setf (box-y box) (- y (u:half (geom:height box)))))

(defmethod (setf tree-x) (x (box box))
  (move-tree box x (geom:y box) t))

(defmethod (setf tree-y) (y (box box))
  (move-tree box (geom:x box) y t))

(defgeneric node-to-list (node)
  (:method-combination append :most-specific-last)
  (:documentation "Turn a box tree native form into a list form."))

(defmethod node-to-list :around ((node tree:node))
  "ensure that children appear last in the list for readability."
  (if (tree:children node)
      `(,@(call-next-method)
          :children ,(mapcar 'node-to-list (tree:children node)))
      (call-next-method)))

(defmethod node-to-list append ((node t))
  (list (type-of node)))

(defmethod node-to-list append ((node interactive-mixin))
  (append (when (arrow node)
            (list :arrow (if (typep (arrow node) 'sdl:color)
                             (export-color (arrow node))
                             (arrow node))))
          (u:simple-list-slots-except-nil node 'selected 'highlighted)))

(defmethod node-to-list append ((node id-mixin))
  (u:simple-list-slots node 'id))

(defmethod node-to-list append ((node color-parts-mixin))
  nil)

(defmethod node-to-list append ((node argument))
  (u:simple-list-slots node 'quantity))

(defmethod node-to-list append ((node input-argument))
  (u:simple-list-slots node 'answer))

(defun list-to-node (l)
  "Turn the list form of a box tree back into the native form."
  (apply 'make-instance (first l)
         :children (mapcar 'list-to-node (getf (cdr l) :children))
         (progn
           (remf (cdr l) :children)
           (cdr l))))

(defun only-boxes (nodes)
  "return those nodes that are boxes."
  (remove-if-not (lambda (n) (typep n 'box)) nodes))

(defun point-to-nodes (tree &rest nodes)
  "Only NODES will have an arrows pointing to them."
  (clear-arrows tree)
  (dolist (n nodes)
    (setf (arrow n) t)))
